home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / utils / smtpmail.el.z / smtpmail.el
Encoding:
Text File  |  1998-05-21  |  16.2 KB  |  546 lines
  1. ;; Simple SMTP protocol (RFC 821) for sending mail
  2.  
  3. ;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
  6. ;; Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu>
  7. ;; Keywords: mail
  8.  
  9. ;; This file is part of XEmacs.
  10.  
  11. ;; XEmacs is free software; you can redistribute it and/or modify it
  12. ;; under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; XEmacs is distributed in the hope that it will be useful, but
  17. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19. ;; General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  23. ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  24. ;; 02111-1307, USA.
  25.  
  26. ;;; Synched up with: FSF 19.34.
  27.  
  28. ;;; Commentary:
  29.  
  30. ;; Send Mail to smtp host from smtpmail temp buffer.
  31.  
  32. ;; Please add these lines in your .emacs(_emacs).
  33. ;;
  34. ;;(setq send-mail-function 'smtpmail-send-it)
  35. ;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST")
  36. ;;(setq smtpmail-smtp-service "smtp")
  37. ;;(setq smtpmail-local-domain "YOUR DOMAIN NAME")
  38. ;;(setq smtpmail-debug-info t)
  39. ;;(load-library "smtpmail")
  40. ;;(setq smtpmail-code-conv-from nil)
  41. ;;(setq user-full-name "YOUR NAME HERE")
  42.  
  43. ;;; Code:
  44.  
  45. (require 'sendmail)
  46.  
  47. ;;;
  48. (defgroup smtpmail nil
  49.   "SMTP protocol for sending mail."
  50.   :group 'mail)
  51.  
  52.  
  53. (defcustom smtpmail-default-smtp-server nil
  54.   "*Specify default SMTP server."
  55.   :type '(choice (const nil) string)
  56.   :group 'smtpmail)
  57.  
  58. (defcustom smtpmail-smtp-server 
  59.   (or (getenv "SMTPSERVER") smtpmail-default-smtp-server)
  60.   "*The name of the host running SMTP server."
  61.   :type '(choice (const nil) string)
  62.   :group 'smtpmail)
  63.  
  64. (defcustom smtpmail-smtp-service 25
  65.   "*SMTP service port number. smtp or 25 ."
  66.   :type '(choice (integer :tag "Port") (string :tag "Service"))
  67.   :group 'smtpmail)
  68.  
  69. (defcustom smtpmail-local-domain nil
  70.   "*Local domain name without a host name.
  71. If the function (system-name) returns the full internet address,
  72. don't define this value."
  73.   :type '(choice (const nil) string)
  74.   :group 'smtpmail)
  75.  
  76. (defcustom smtpmail-debug-info nil
  77.   "*smtpmail debug info printout. messages and process buffer."
  78.   :type 'boolean
  79.   :group 'smtpmail)
  80.  
  81. (defcustom smtpmail-code-conv-from nil ;; *junet*
  82.   "*smtpmail code convert from this code to *internal*..for tiny-mime.."
  83.   :type 'boolean
  84.   :group 'smtpmail)
  85.  
  86. ;;;
  87. ;;;
  88. ;;;
  89.  
  90. ;;;###autoload
  91. (defun smtpmail-send-it ()
  92.   (require 'mail-utils)
  93.   (let ((errbuf (if mail-interactive
  94.             (generate-new-buffer " smtpmail errors")
  95.           0))
  96.     (tembuf (generate-new-buffer " smtpmail temp"))
  97.     (case-fold-search nil)
  98.     resend-to-addresses
  99.     delimline
  100.     (mailbuf (current-buffer)))
  101.     (unwind-protect
  102.     (save-excursion
  103.       (set-buffer tembuf)
  104.       (erase-buffer)
  105.       (insert-buffer-substring mailbuf)
  106.       (goto-char (point-max))
  107.       ;; require one newline at the end.
  108.       (or (= (preceding-char) ?\n)
  109.           (insert ?\n))
  110.       ;; Change header-delimiter to be what sendmail expects.
  111.       (goto-char (point-min))
  112.       (re-search-forward
  113.         (concat "^" (regexp-quote mail-header-separator) "\n"))
  114.       (replace-match "\n")
  115.       (backward-char 1)
  116.       (setq delimline (point-marker))
  117. ;;      (sendmail-synch-aliases)
  118.       (if (and mail-aliases (fboundp 'expand-mail-aliases)) ; XEmacs
  119.           (expand-mail-aliases (point-min) delimline))
  120.       (goto-char (point-min))
  121.       ;; ignore any blank lines in the header
  122.       (while (and (re-search-forward "\n\n\n*" delimline t)
  123.               (< (point) delimline))
  124.         (replace-match "\n"))
  125.       (let ((case-fold-search t))
  126.         (goto-char (point-min))
  127.         (goto-char (point-min))
  128.         (while (re-search-forward "^Resent-to:" delimline t)
  129.           (setq resend-to-addresses
  130.             (save-restriction
  131.               (narrow-to-region (point)
  132.                     (save-excursion
  133.                       (end-of-line)
  134.                       (point)))
  135.               (append (mail-parse-comma-list)
  136.                   resend-to-addresses))))
  137. ;;; Apparently this causes a duplicate Sender.
  138. ;;;        ;; If the From is different than current user, insert Sender.
  139. ;;;        (goto-char (point-min))
  140. ;;;        (and (re-search-forward "^From:"  delimline t)
  141. ;;;         (progn
  142. ;;;           (require 'mail-utils)
  143. ;;;           (not (string-equal
  144. ;;;             (mail-strip-quoted-names
  145. ;;;              (save-restriction
  146. ;;;                (narrow-to-region (point-min) delimline)
  147. ;;;                (mail-fetch-field "From")))
  148. ;;;             (user-login-name))))
  149. ;;;         (progn
  150. ;;;           (forward-line 1)
  151. ;;;           (insert "Sender: " (user-login-name) "\n")))
  152.         ;; Don't send out a blank subject line
  153.         (goto-char (point-min))
  154.         (if (re-search-forward "^Subject:[ \t]*\n" delimline t)
  155.         (replace-match ""))
  156.         ;; Put the "From:" field in unless for some odd reason
  157.         ;; they put one in themselves.
  158.         (goto-char (point-min))
  159.         (if (not (re-search-forward "^From:" delimline t))
  160.         (let* ((login (user-mail-address))
  161.                (fullname (user-full-name)))
  162.           (cond ((eq mail-from-style 'angles)
  163.              (insert "From: " fullname)
  164.              (let ((fullname-start (+ (point-min) 6))
  165.                    (fullname-end (point-marker)))
  166.                (goto-char fullname-start)
  167.                ;; Look for a character that cannot appear unquoted
  168.                ;; according to RFC 822.
  169.                (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]"
  170.                           fullname-end 1)
  171.                    (progn
  172.                  ;; Quote fullname, escaping specials.
  173.                  (goto-char fullname-start)
  174.                  (insert "\"")
  175.                  (while (re-search-forward "[\"\\]"
  176.                                fullname-end 1)
  177.                    (replace-match "\\\\\\&" t))
  178.                  (insert "\""))))
  179.              (insert " <" login ">\n"))
  180.             ((eq mail-from-style 'parens)
  181.              (insert "From: " login " (")
  182.              (let ((fullname-start (point)))
  183.                (insert fullname)
  184.                (let ((fullname-end (point-marker)))
  185.                  (goto-char fullname-start)
  186.                  ;; RFC 822 says \ and nonmatching parentheses
  187.                  ;; must be escaped in comments.
  188.                  ;; Escape every instance of ()\ ...
  189.                  (while (re-search-forward "[()\\]" fullname-end 1)
  190.                    (replace-match "\\\\\\&" t))
  191.                  ;; ... then undo escaping of matching parentheses,
  192.                  ;; including matching nested parentheses.
  193.                  (goto-char fullname-start)
  194.                  (while (re-search-forward 
  195.                      "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
  196.                      fullname-end 1)
  197.                    (replace-match "\\1(\\3)" t)
  198.                    (goto-char fullname-start))))
  199.              (insert ")\n"))
  200.             ((null mail-from-style)
  201.              (insert "From: " login "\n")))))
  202.         ;; Insert an extra newline if we need it to work around
  203.         ;; Sun's bug that swallows newlines.
  204.         (goto-char (1+ delimline))
  205.         (if (eval mail-mailer-swallows-blank-line)
  206.         (newline))
  207.         ;; Find and handle any FCC fields.
  208.         (goto-char (point-min))
  209.         (if (re-search-forward "^FCC:" delimline t)
  210.         (mail-do-fcc delimline))
  211.         (if mail-interactive
  212.         (save-excursion
  213.           (set-buffer errbuf)
  214.           (erase-buffer))))
  215.       ;;
  216.       ;;
  217.       ;;
  218.       (setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*"))
  219.       (setq smtpmail-recipient-address-list
  220.         (or resend-to-addresses
  221.             (smtpmail-deduce-address-list tembuf (point-min) delimline)))
  222.       (kill-buffer smtpmail-address-buffer)
  223.  
  224.       (smtpmail-do-bcc delimline)
  225.  
  226.       (if (not (null smtpmail-recipient-address-list))
  227.           (if (not (smtpmail-via-smtp smtpmail-recipient-address-list tembuf))
  228.           (error "Sending failed; SMTP protocol error"))
  229.         (error "Sending failed; no recipients"))
  230.       )
  231.       (kill-buffer tembuf)
  232.       (if (bufferp errbuf)
  233.       (kill-buffer errbuf)))))
  234.  
  235.  
  236. ;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer)
  237.  
  238. (defun smtpmail-fqdn ()
  239.   (if smtpmail-local-domain
  240.       (concat (system-name) "." smtpmail-local-domain)
  241.     (system-name)))
  242.  
  243. (defun smtpmail-via-smtp (recipient smtpmail-text-buffer)
  244.   (let ((process nil)
  245.     (host smtpmail-smtp-server)
  246.     (port smtpmail-smtp-service)
  247.     response-code
  248.     greeting
  249.     process-buffer)
  250.     (unwind-protect
  251.     (catch 'done
  252.       ;; get or create the trace buffer
  253.       (setq process-buffer
  254.         (get-buffer-create (format "*trace of SMTP session to %s*" host)))
  255.  
  256.       ;; clear the trace buffer of old output
  257.       (save-excursion
  258.         (set-buffer process-buffer)
  259.         (erase-buffer))
  260.  
  261.       ;; open the connection to the server
  262.       (setq process (open-network-stream "SMTP" process-buffer host port))
  263.       (and (null process) (throw 'done nil))
  264.  
  265.       ;; set the send-filter
  266.       (set-process-filter process 'smtpmail-process-filter)
  267.  
  268.       (save-excursion
  269.         (set-buffer process-buffer)
  270.         (make-local-variable 'smtpmail-read-point)
  271.         (setq smtpmail-read-point (point-min))
  272.  
  273.         
  274.         (if (or (null (car (setq greeting (smtpmail-read-response process))))
  275.             (not (integerp (car greeting)))
  276.             (>= (car greeting) 400))
  277.         (throw 'done nil)
  278.           )
  279.  
  280.         ;; HELO
  281.         (smtpmail-send-command process (format "HELO %s" (smtpmail-fqdn)))
  282.  
  283.         (if (or (null (car (setq response-code (smtpmail-read-response process))))
  284.             (not (integerp (car response-code)))
  285.             (>= (car response-code) 400))
  286.         (throw 'done nil)
  287.           )
  288.  
  289.         ;; MAIL FROM: <sender>
  290. ;        (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn)))
  291.         (smtpmail-send-command process (format "MAIL FROM: <%s>" (user-mail-address)))
  292.  
  293.         (if (or (null (car (setq response-code (smtpmail-read-response process))))
  294.             (not (integerp (car response-code)))
  295.             (>= (car response-code) 400))
  296.         (throw 'done nil)
  297.           )
  298.         
  299.         ;; RCPT TO: <recipient>
  300.         (let ((n 0))
  301.           (while (not (null (nth n recipient)))
  302.         (smtpmail-send-command process (format "RCPT TO: <%s>" (nth n recipient)))
  303.         (setq n (1+ n))
  304.  
  305.         (if (or (null (car (setq response-code (smtpmail-read-response process))))
  306.             (not (integerp (car response-code)))
  307.             (>= (car response-code) 400))
  308.             (throw 'done nil)
  309.           )
  310.         ))
  311.         
  312.         ;; DATA
  313.         (smtpmail-send-command process "DATA")
  314.  
  315.         (if (or (null (car (setq response-code (smtpmail-read-response process))))
  316.             (not (integerp (car response-code)))
  317.             (>= (car response-code) 400))
  318.         (throw 'done nil)
  319.           )
  320.  
  321.         ;; Mail contents
  322.         (smtpmail-send-data process smtpmail-text-buffer)
  323.  
  324.         ;;DATA end "."
  325.         (smtpmail-send-command process ".")
  326.  
  327.         (if (or (null (car (setq response-code (smtpmail-read-response process))))
  328.             (not (integerp (car response-code)))
  329.             (>= (car response-code) 400))
  330.         (throw 'done nil)
  331.           )
  332.  
  333.         ;;QUIT
  334. ;        (smtpmail-send-command process "QUIT")
  335. ;        (and (null (car (smtpmail-read-response process)))
  336. ;         (throw 'done nil))
  337.         t ))
  338.       (if process
  339.       (save-excursion
  340.         (set-buffer (process-buffer process))
  341.         (smtpmail-send-command process "QUIT")
  342.         (smtpmail-read-response process)
  343.  
  344. ;        (if (or (null (car (setq response-code (smtpmail-read-response process))))
  345. ;            (not (integerp (car response-code)))
  346. ;            (>= (car response-code) 400))
  347. ;        (throw 'done nil)
  348. ;          )
  349.         (delete-process process))))))
  350.  
  351.  
  352. (defun smtpmail-process-filter (process output)
  353.   (save-excursion
  354.     (set-buffer (process-buffer process))
  355.     (goto-char (point-max))
  356.     (insert output)))
  357.  
  358. (defun smtpmail-read-response (process)
  359.   (let ((case-fold-search nil)
  360.     (response-string nil)
  361.     (response-continue t)
  362.     (return-value '(nil ""))
  363.     match-end)
  364.  
  365. ;    (setq response-string nil)
  366. ;    (setq response-continue t)
  367. ;    (setq return-value '(nil ""))
  368.  
  369.     (while response-continue
  370.       (goto-char smtpmail-read-point)
  371.       (while (not (search-forward "\r\n" nil t))
  372.     (accept-process-output process)
  373.     (goto-char smtpmail-read-point))
  374.  
  375.       (setq match-end (point))
  376.       (if (null response-string)
  377.       (setq response-string
  378.         (buffer-substring smtpmail-read-point (- match-end 2))))
  379.     
  380.       (goto-char smtpmail-read-point)
  381.       (if (looking-at "[0-9]+ ")
  382.       (progn (setq response-continue nil)
  383. ;         (setq return-value response-string)
  384.  
  385.          (if smtpmail-debug-info
  386.              (message response-string))
  387.  
  388.          (setq smtpmail-read-point match-end)
  389.          (setq return-value
  390.                (cons (string-to-int 
  391.                   (buffer-substring (match-beginning 0) (match-end 0))) 
  392.                  response-string)))
  393.     
  394.     (if (looking-at "[0-9]+-")
  395.         (progn (setq smtpmail-read-point match-end)
  396.            (setq response-continue t))
  397.       (progn
  398.         (setq smtpmail-read-point match-end)
  399.         (setq response-continue nil)
  400.         (setq return-value 
  401.           (cons nil response-string))
  402.         )
  403.       )))
  404.     (setq smtpmail-read-point match-end)
  405.     return-value))
  406.  
  407.  
  408. (defun smtpmail-send-command (process command)
  409.   (goto-char (point-max))
  410.   (if (= (aref command 0) ?P)
  411.       (insert "PASS <omitted>\r\n")
  412.     (insert command "\r\n"))
  413.   (setq smtpmail-read-point (point))
  414.   (process-send-string process command)
  415.   (process-send-string process "\r\n"))
  416.  
  417. (defun smtpmail-send-data-1 (process data)
  418.   (goto-char (point-max))
  419.  
  420.   (if (not (null smtpmail-code-conv-from))
  421.       (setq data (code-convert-string data smtpmail-code-conv-from *internal*)))
  422.     
  423.   (if smtpmail-debug-info
  424.       (insert data "\r\n"))
  425.  
  426.   (setq smtpmail-read-point (point))
  427.   ;; Escape "." at start of a line
  428.   (if (eq (string-to-char data) ?.)
  429.       (process-send-string process "."))
  430.   (process-send-string process data)
  431.   (process-send-string process "\r\n")
  432.   )
  433.  
  434. (defun smtpmail-send-data (process buffer)
  435.   (let
  436.       ((data-continue t)
  437.        (sending-data nil)
  438.        this-line
  439.        this-line-end)
  440.  
  441.     (save-excursion
  442.       (set-buffer buffer)
  443.       (goto-char (point-min)))
  444.  
  445.     (while data-continue
  446.       (save-excursion
  447.     (set-buffer buffer)
  448.     (beginning-of-line)
  449.     (setq this-line (point))
  450.     (end-of-line)
  451.     (setq this-line-end (point))
  452.     (setq sending-data nil)
  453.     (setq sending-data (buffer-substring this-line this-line-end))
  454.     (if (/= (forward-line 1) 0)
  455.         (setq data-continue nil)))
  456.  
  457.       (smtpmail-send-data-1 process sending-data)
  458.       )
  459.     )
  460.   )
  461.     
  462.  
  463. (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end)
  464.   "Get address list suitable for smtp RCPT TO: <address>."
  465.   (require 'mail-utils)  ;; pick up mail-strip-quoted-names
  466.   (let
  467.       ((simple-address-list "")
  468.        this-line
  469.        this-line-end
  470.        addr-regexp)
  471.     
  472.     (unwind-protect
  473.     (save-excursion
  474.       ;;
  475.       (set-buffer smtpmail-address-buffer) (erase-buffer)
  476.       (let ((case-fold-search t))
  477.       (insert-buffer-substring smtpmail-text-buffer header-start header-end)
  478.       (goto-char (point-min))
  479.       ;; RESENT-* fields should stop processing of regular fields.
  480.       (save-excursion
  481.         (if (re-search-forward "^RESENT-TO:" header-end t)
  482.         (setq addr-regexp "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
  483.           (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
  484.  
  485.       (while (re-search-forward addr-regexp header-end t)
  486.         (replace-match "")
  487.         (setq this-line (match-beginning 0))
  488.         (forward-line 1)
  489.         ;; get any continuation lines
  490.         (while (and (looking-at "^[ \t]+") (< (point) header-end))
  491.           (forward-line 1))
  492.         (setq this-line-end (point-marker))
  493.         (setq simple-address-list
  494.           (concat simple-address-list " "
  495.               (mail-strip-quoted-names (buffer-substring this-line this-line-end))))
  496.         )
  497.       (erase-buffer)
  498.       (insert-string " ")
  499.       (insert-string simple-address-list)
  500.       (insert-string "\n")
  501.       (subst-char-in-region (point-min) (point-max) 10 ?  t);; newline --> blank
  502.       (subst-char-in-region (point-min) (point-max) ?, ?  t);; comma   --> blank
  503.       (subst-char-in-region (point-min) (point-max)  9 ?  t);; tab     --> blank
  504.  
  505.       (goto-char (point-min))
  506.       ;; tidyness in case hook is not robust when it looks at this
  507.       (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
  508.  
  509.       (goto-char (point-min))
  510.       (let (recipient-address-list)
  511.         (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
  512.           (backward-char 1)
  513.           (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1))
  514.                          recipient-address-list))
  515.           )
  516.         (setq smtpmail-recipient-address-list recipient-address-list))
  517.  
  518.       ))
  519.       )
  520.     )
  521.   )
  522.  
  523.  
  524. (defun smtpmail-do-bcc (header-end)
  525.   "Delete BCC: and their continuation lines from the header area.
  526. There may be multiple BCC: lines, and each may have arbitrarily
  527. many continuation lines."
  528.   (let ((case-fold-search t))
  529.     (save-excursion (goto-char (point-min))
  530.       ;; iterate over all BCC: lines
  531.       (while (re-search-forward "^BCC:" header-end t)
  532.             (delete-region (match-beginning 0) (progn (forward-line 1) (point)))
  533.         ;; get rid of any continuation lines
  534.         (while (and (looking-at "^[ \t].*\n") (< (point) header-end))
  535.           (replace-match ""))
  536.         )
  537.       ) ;; save-excursion
  538.     ) ;; let
  539.   )
  540.  
  541.  
  542.  
  543. (provide 'smtpmail)
  544.  
  545. ;; smtpmail.el ends here
  546.